home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
make_ufun.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
3KB
|
72 lines
;;; MAKE_UFUN Makes Ufun list for user-defined functions.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(defvar gazonk (make-package 'symbol-table :use nil))
(defvar eof (cons nil nil))
(defvar *Ufun-out*)
(defvar *str* (make-array 128 :element-type 'string-char :fill-pointer 0))
(defun make-Ufun (in-files &key (out-file "Ufun_list.lsp"))
(with-open-file (*Ufun-out* out-file :direction :output)
(print '(in-package "COMPILER") *Ufun-out*)
(dolist (file in-files)
(with-open-file (in (merge-pathnames file #".lsp"))
(loop (when (eq (setq form (read in nil eof)) eof) (return))
(do-form form))))))
(defun do-form (form)
(when (consp form)
(case (car form)
(defun
(let ((*package* (find-package 'compiler)))
(print `(si:putprop
',(cadr form)
,(get-cname (cadr form))
'Ufun)
*Ufun-out*))
(eval form))
(progn (mapc #'do-form (cdr form)))
(eval-when
(if (member 'load (cadr form))
(mapc #'do-form (cddr form))
(if (member 'compile (cadr form))
(mapc #'eval (cddr form)))))
(t
(if (macro-function (car form))
(do-form (macroexpand-1 form))
(eval form))))))
(defun get-cname (symbol &aux (name (symbol-name symbol)))
(setf (fill-pointer *str*) 0)
(vector-push #\U *str*)
(dotimes (n (length name))
(let ((char (schar name n)))
(cond ((alphanumericp char)
(vector-push (char-downcase char) *str*))
((char= char #\-) (vector-push #\_ *str*))
((char= char #\*) (vector-push #\A *str*))
)))
(multiple-value-bind (foo flag) (find-symbol *str* 'symbol-table)
(unless flag
;(setq foo (intern (copy-seq *str*) 'symbol-table))
(setq foo (intern *str* 'symbol-table))
;(set foo nil)
(return-from get-cname *str*))
(gensym *str*)
(gensym 0)
(loop
(setq name (symbol-name (gensym)))
(multiple-value-bind (foo flag1)
(intern name 'symbol-table)
(unless flag1
;(set foo nil)
(return-from get-cname name)))))
)